home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turnbull China Bikeride
/
Turnbull China Bikeride - Disc 2.iso
/
STUTTGART
/
LANG
/
LISP
/
XLISP
/
XLISP21S
/
sources
/
c
/
xlprin
< prev
next >
Wrap
Text File
|
1992-04-25
|
18KB
|
658 lines
/* xlprint - xlisp print routine */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
/* external variables */
extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
extern LVAL s_ifmt,s_ffmt;
#ifdef RATIOS
extern LVAL s_rfmt;
#endif
extern LVAL s_printlevel, s_printlength; /* TAA mod */
extern LVAL obarray;
extern FUNDEF funtab[];
#ifdef READTABLECASE
extern LVAL s_rtcase,k_upcase,k_preserve,k_invert;
#endif
#ifdef HASHFCNS
extern LVAL a_hashtable;
#endif
/* forward declarations */
#ifdef ANSI
void NEAR putsymbol(LVAL fptr, char FAR *str, int flag);
void NEAR putstring(LVAL fptr, LVAL str);
void NEAR putqstring(LVAL fptr, LVAL str);
void NEAR putatm(LVAL fptr, char *tag, LVAL val);
void NEAR putsubr(LVAL fptr, char *tag, LVAL val);
void NEAR putclosure(LVAL fptr, LVAL val);
void NEAR putfixnum(LVAL fptr, FIXTYPE n);
#ifdef RATIOS
void NEAR putratio(LVAL fptr, FIXTYPE n, FIXTYPE d);
#endif
void NEAR putflonum(LVAL fptr, FLOTYPE n);
void NEAR putchcode(LVAL fptr, int ch, int escflag);
void NEAR putoct(LVAL fptr, int n);
#else
FORWARD VOID putsymbol();
FORWARD VOID putstring();
FORWARD VOID putqstring();
FORWARD VOID putatm();
FORWARD VOID putsubr();
FORWARD VOID putclosure();
FORWARD VOID putfixnum();
FORWARD VOID putflonum();
#ifdef RATIOS
FORWARD VOID putratio();
#endif
FORWARD VOID putchcode();
FORWARD VOID putoct();
#endif
#ifdef ANSI
void xlprintl(LVAL fptr, LVAL vptr, int flag);
#else
FORWARD VOID xlprintl();
#endif
int plevel,plength;
/* $putpatch.c$: "MODULE_XLPRIN_C_GLOBALS" */
/* xlprint - print an xlisp value */
VOID xlprint(fptr,vptr,flag)
LVAL fptr,vptr; int flag;
{
LVAL temp;
temp = getvalue(s_printlevel);
if (fixp(temp) && getfixnum(temp) <= 32767 && getfixnum(temp) >= 0) {
plevel = (int)getfixnum(temp);
}
else {
plevel = 32767; /* clamp to "reasonable" level */
}
temp = getvalue(s_printlength);
if (fixp(temp) && getfixnum(temp) <= 32767 && getfixnum(temp) >= 0) {
plength = (int)getfixnum(temp);
}
else
plength = 32767;
xlprintl(fptr,vptr,flag);
}
VOID xlprintl(fptr,vptr,flag)
LVAL fptr,vptr; int flag;
{
LVAL nptr,next;
int n,i;
int llength;
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
if (plevel-- == 0) { /* depth limitation */
xlputc(fptr,'#');
plevel++;
break;
}
xlputc(fptr,'(');
llength = plength;
for (nptr = vptr; nptr != NIL; nptr = next) {
if (llength-- == 0) { /* length limitiation */
xlputstr(fptr,"... ");
break;
}
xlprintl(fptr,car(nptr),flag);
if ((next = cdr(nptr)) != NIL)
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprintl(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
plevel++;
break;
case SYMBOL:
/* check for uninterned symbol */
{
char FAR *str = getstring(getpname(vptr));
if (flag) {
next = getelement(getvalue(obarray), hash(str, HSIZE));
for (; !null(next); next = cdr(next))
if (car(next) == vptr) goto doprintsym;
xlputstr(fptr,"#:");
doprintsym: ;
}
putsymbol(fptr, str, flag);
break;
}
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
#ifdef FILETABLE
{
char *msg;
FILEP fp = getfile(vptr);
if (fp == CLOSED) xlputstr(fptr, "#<Closed-Stream>");
else {
switch (vptr->n_sflags & (S_FORREADING | S_FORWRITING)) {
case S_FORREADING: msg = "Input-Stream"; break;
case S_FORWRITING: msg = "Output-Stream"; break;
default: msg = "IO-Stream"; break;
}
sprintf(buf,"#<%s %d:\"%s\">", msg, fp+1, filetab[fp].tname);
xlputstr(fptr,buf);
}
}
#else
{
char *msg;
FILEP fp = getfile(vptr);
if (fp == CLOSED) msg = "Closed-Stream";
else if (fp == STDIN) msg = "Stdin-Stream";
else if (fp == STDOUT) msg = "Stdout-Stream";
else if (fp == CONSOLE) msg = "Terminal-Stream";
else switch (vptr->n_sflags & (S_FORREADING | S_FORWRITING)) {
case S_FORREADING: msg = "Input-Stream"; break;
case S_FORWRITING: msg = "Output-Stream"; break;
default: msg = "IO-Stream"; break;
}
putatm(fptr,msg,vptr);
}
#endif
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
/* putobj fakes a (send obj :prin1 file) call */
putobj(fptr,vptr);
break;
case VECTOR:
if (plevel-- == 0) { /* depth limitation */
xlputc(fptr,'#');
plevel++;
break;
}
xlputc(fptr,'#'); xlputc(fptr,'(');
llength = plength;
for (i = 0, n = getsize(vptr); n-- > 0; ) {
if (llength-- == 0) { /* length limitiation */
xlputstr(fptr,"... ");
break;
}
xlprintl(fptr,getelement(vptr,i++),flag);
if (n) xlputc(fptr,' ');
}
xlputc(fptr,')');
plevel++;
break;
case STRUCT:
#ifdef HASHFCNS
if (getelement(vptr,0) == a_hashtable) {
putatm(fptr,"Hash-table",vptr);
break;
}
#endif
xlprstruct(fptr,vptr,flag);
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
#ifdef RATIOS
case RATIO:
putratio(fptr, getnumer(vptr), getdenom(vptr));
break;
#endif
#ifdef COMPLX
case COMPLEX:
xlputstr(fptr, "#C(");
if (ntype(next = getelement(vptr,0)) == FIXNUM)
putfixnum(fptr, getfixnum(next));
else
putflonum(fptr, getflonum(next));
xlputc(fptr,' ');
if (ntype(next = getelement(vptr,1)) == FIXNUM)
putfixnum(fptr, getfixnum(next));
else
putflonum(fptr, getflonum(next));
xlputc(fptr, ')');
break;
#endif
case FREE:
putatm(fptr,"Free",vptr);
break;
/* $putpatch.c$: "MODULE_XLPRIN_C_XLPRINT" */
default:
putatm(fptr,"Unknown",vptr); /* was 'Foo` TAA Mod */
break;
}
}
/* xlterpri - terminate the current print line */
VOID xlterpri(fptr)
LVAL fptr;
{
xlputc(fptr,'\n');
}
extern int lposition; /* imported from the *stuff.c file */
/* xlgetcolumn -- find the current file column */
int xlgetcolumn(fptr)
LVAL fptr;
{
if (fptr == NIL) return 0;
else if (ntype(fptr) == USTREAM) { /* hard work ahead :-( */
LVAL ptr = gethead(fptr);
int count = 0;
while (ptr != NIL) {
if (getchcode(ptr) == '\n') count = 0 ;
else count++;
ptr = cdr(ptr);
}
return count;
}
else if (getfile(fptr) == CONSOLE)
return lposition;
else
return ((fptr->n_sflags & S_WRITING)? fptr->n_cpos : 0);
}
/* xlfreshline -- start new line if not at beginning of line */
int xlfreshline(fptr)
LVAL fptr;
{
if (xlgetcolumn(fptr) != 0) {
xlterpri(fptr);
return TRUE;
}
return FALSE;
}
/* xlputstr - output a string */
VOID xlputstr(fptr,str)
LVAL fptr; char *str;
{
/* solve reentrancy problems if gc prints messages and
xlputstr output is directed to a string stream */
if (ustreamp(fptr)) {
int oplevel=plevel, oplength=plength; /* save these variables */
char nbuf[STRMAX+1];
if (buf == str) { /* copy to reentrant buffer if necessary */
str = strcpy(nbuf, buf);
}
while (*str) /* print string */
xlputc(fptr, *str++);
plevel = oplevel; /* restore level and length */
plength = oplength;
}
else
while (*str)
xlputc(fptr,*str++);
}
#ifdef READTABLECASE
#define RUP 0 /* values for upcase, downcase, preserve, and invert */
#define RDWN 1
#define RPRE 2
#define RINV 3
#endif
/* putsymbol - output a symbol */
LOCAL VOID NEAR putsymbol(fptr, stri, flag)
LVAL fptr; char FAR *stri; int flag;
{
#ifdef READTABLECASE
LVAL rtcase = getvalue(s_rtcase);
int rcase,up,low;
int mixcase;
#endif
int downcase;
LVAL type;
char *p,c;
#ifdef MEDMEM
char *str = buf;
STRCPY(buf, stri);
#else
#define str stri
#endif
#ifdef READTABLECASE
/* check value of *readtable-case* */
if (rtcase == k_upcase) rcase = RUP;
else if (rtcase == k_invert) rcase = RINV;
else if (rtcase == k_downcase) rcase = RDWN;
else if (rtcase == k_preserve) rcase = RPRE;
else rcase = RUP; /* default is upcase */
#endif
/* handle escaping if flag is true */
if (flag) {
/* check to see if symbol needs escape characters */
for (p = str; *p; ++p)
#ifdef READTABLECASE
if (rcase == RUP && islower(*p)
|| rcase == RDWN && isupper(*p)
|| ((type = tentry(*p)) != k_const
&& (!consp(type) || car(type) != k_nmacro)))
#else
if (islower(*p)
|| ((type = tentry(*p)) != k_const
&& (!consp(type) || car(type) != k_nmacro)))
#endif
{
xlputc(fptr,'|');
while (*str) {
if (*str == '\\' || *str == '|')
xlputc(fptr,'\\');
xlputc(fptr,*str++);
}
xlputc(fptr,'|');
return;
}
/* check for the first character being '#'
or string looking like a number */
if (*str == '#' || isnumber(str,NULL))
xlputc(fptr,'\\');
}
/* get the case translation flag -- default upcase */
downcase = (getvalue(s_printcase) == k_downcase);
#ifdef READTABLECASE
/* we need to know if there is a mixed case symbol if reading :INVERT */
if (rcase == RINV) {
up=FALSE;
low=FALSE;
mixcase = FALSE;
for (p=str ; *p && !mixcase ; ++p) {
if (islower(*p))
low = TRUE;
else if (isupper(*p))
up = TRUE;
mixcase = up&low;
}
if (mixcase) rcase = RPRE; /* preserve if cases mixed */
}
low = (rcase == RINV) || (rcase == RUP && downcase);
up = (rcase == RINV) || (rcase == RDWN && !downcase);
#endif
/* output each character */
while ((c = *str++) != 0) {
if (flag && (c == '\\' || c == '|'))
xlputc(fptr,'\\');
#ifdef READTABLECASE
if (isupper(c)) xlputc(fptr, low ? tolower(c) : c);
else if (islower(c)) xlputc(fptr, up ? toupper(c) : c);
else xlputc(fptr,c);
#else
xlputc(fptr,(downcase && isupper(c) ? tolower(c) : c));
#endif
}
}
#ifndef MEDMEM
#undef str
#endif
/* putstring - output a string */
/* rewritten to print strings containing nulls TAA mod*/
LOCAL VOID NEAR putstring(fptr,str)
LVAL fptr,str;
{
char FAR *p = getstring(str);
unsigned len = getslength(str);
/* output each character */
while (len-- > 0) xlputc(fptr,*p++);
}
/* putqstring - output a quoted string */
/* rewritten to print strings containing nulls TAA mod*/
LOCAL VOID NEAR putqstring(fptr,str)
LVAL fptr,str;
{
char FAR *p = getstring(str);
unsigned len = getslength(str);
int ch;
/* output the initial quote */
xlputc(fptr,'"');
/* output each character in the string */
while (len-- > 0) {
ch = *(unsigned char FAR *)p++;
/* check for a control character */
if (ch < 040 || ch == '\\' || ch == '"' || ch > 0176) { /* TAA MOD quote quote */
xlputc(fptr,'\\');
switch (ch) {
case '\011':
xlputc(fptr,'t');
break;
case '\012':
xlputc(fptr,'n');
break;
case '\014':
xlputc(fptr,'f');
break;
case '\015':
xlputc(fptr,'r');
break;
case '\\':
case '"':
xlputc(fptr,ch);
break;
default:
putoct(fptr,ch);
break;
}
}
/* output a normal character */
else
xlputc(fptr,ch);
}
/* output the terminating quote */
xlputc(fptr,'"');
}
/* putatm - output an atom */
LOCAL VOID NEAR putatm(fptr,tag,val)
LVAL fptr; char *tag; LVAL val;
{
sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putsubr - output a subr/fsubr */
LOCAL VOID NEAR putsubr(fptr,tag,val)
LVAL fptr; char *tag; LVAL val;
{
/* sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name); */
char *str; /* TAA mod */
if ((str = funtab[getoffset(val)].fd_name) != NULL)
sprintf(buf,"#<%s-%s: #",tag,str);
else
sprintf(buf,"#<%s: #",tag);
xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putclosure - output a closure */
LOCAL VOID NEAR putclosure(fptr,val)
LVAL fptr,val;
{
LVAL name;
if ((name = getname(val)) != NIL)
sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
else
strcpy(buf,"#<Closure: #");
xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putfixnum - output a fixnum */
LOCAL VOID NEAR putfixnum(fptr,n)
LVAL fptr; FIXTYPE n;
{
LVAL val;
#ifdef MEDMEM
char fmt[STRMAX];
val = getvalue(s_ifmt);
STRCPY(fmt, stringp(val) && getslength(val) < STRMAX ?
getstring(val) : (char FAR *)IFMT);
#else
char *fmt;
val = getvalue(s_ifmt);
fmt = (stringp(val) ? getstring(val) : IFMT);
#endif
sprintf(buf,fmt,n);
xlputstr(fptr,buf);
}
#ifdef RATIOS
LOCAL VOID NEAR putratio(fptr,n,d)
LVAL fptr; FIXTYPE n,d;
{
LVAL val;
#ifdef MEDMEM
char fmt[STRMAX];
val = getvalue(s_rfmt);
STRCPY(fmt, (stringp(val) && getslength(val) < STRMAX ?
getstring(val) : (char FAR *)RFMT));
#else
char *fmt;
val = getvalue(s_rfmt);
fmt = (stringp(val) ? getstring(val) : RFMT);
#endif
sprintf(buf,fmt,n,d);
xlputstr(fptr,buf);
}
#endif
/* putflonum - output a flonum */
LOCAL VOID NEAR putflonum(fptr,n)
LVAL fptr; FLOTYPE n;
{
#ifdef MEDMEM
char fmt[STRMAX];
#else
char *fmt;
#endif
LVAL val;
#ifdef IEEEFP
union { FLOTYPE fpn; long intn[2]; } k/*ludge*/;
k.fpn = n;
if ((k.intn[1] & 0x7fffffffL) == 0x7ff00000L && k.intn[0] == 0) {
xlputstr(fptr,k.intn[1]<0 ? "-INF" : "+INF");
return;
}
if ((k.intn[1]&0x7ff00000L) == 0x7ff00000L &&
((k.intn[1]&0xfffffL) != 0 || k.intn[0] != 0)) {
xlputstr(fptr,"NaN");
return;
}
#endif
#ifdef MEDMEM
val = getvalue(s_ffmt);
STRCPY(fmt, stringp(val) && getslength(val) < STRMAX ?
getstring(val) : (char FAR *)"%g");
#else
val = getvalue(s_ffmt);
fmt = (stringp(val) ? getstring(val) : "%g");
#endif
sprintf(buf,fmt,n);
xlputstr(fptr,buf);
}
/* putchcode - output a character */
/* modified to print control and meta characters TAA Mod */
LOCAL VOID NEAR putchcode(fptr,ch,escflag)
LVAL fptr; int ch,escflag;
{
if (escflag) {
xlputstr(fptr,"#\\");
if (ch > 127) {
ch -= 128;
xlputstr(fptr,"M-");
}
switch (ch) {
case '\n':
xlputstr(fptr,"Newline");
break;
case ' ':
xlputstr(fptr,"Space");
break;
case 127:
xlputstr(fptr,"Rubout");
break;
default:
if (ch < 32) {
ch += '@';
xlputstr(fptr,"C-");
}
xlputc(fptr,ch);
break;
}
}
else xlputc(fptr,ch);
}
/* putoct - output an octal byte value */
LOCAL VOID NEAR putoct(fptr,n)
LVAL fptr; int n;
{
sprintf(buf,"%03o",n);
xlputstr(fptr,buf);
}